home *** CD-ROM | disk | FTP | other *** search
/ Sprite 1984 - 1993 / Sprite 1984 - 1993.iso / src / lib / tclX6.4c / dist / tclsrc / help.tcl < prev    next >
Encoding:
Text File  |  1992-11-07  |  7.7 KB  |  260 lines
  1. #
  2. # help.tcl --
  3. #
  4. # Tcl help command. (see TclX manual)
  5. # 
  6. #------------------------------------------------------------------------------
  7. # Copyright 1992 Karl Lehenbauer and Mark Diekhans.
  8. #
  9. # Permission to use, copy, modify, and distribute this software and its
  10. # documentation for any purpose and without fee is hereby granted, provided
  11. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  12. # Mark Diekhans make no representations about the suitability of this
  13. # software for any purpose.  It is provided "as is" without express or
  14. # implied warranty.
  15. #------------------------------------------------------------------------------
  16. # $Id: help.tcl,v 2.0 1992/10/16 04:52:01 markd Rel $
  17. #------------------------------------------------------------------------------
  18. #
  19.  
  20. #@package: TclX-help help helpcd helppwd apropos
  21.  
  22. #------------------------------------------------------------------------------
  23. # Take a path name which might have . and .. elements and flatten them out.
  24.  
  25. proc help:flattenPath {pathName} {
  26.     set newPath {}
  27.     foreach element [split $pathName /] {
  28.         if {"$element" == "."} {
  29.            continue
  30.         }
  31.         if {"$element" == ".."} {
  32.             if {[llength [join $newPath /]] == 0} {
  33.                 error "Help: name goes above subject directory root"}
  34.             lvarpop newPath [expr [llength $newPath]-1]
  35.             continue
  36.         }
  37.         lappend newPath $element
  38.     }
  39.     set newPath [join $newPath /]
  40.     
  41.     # Take care of the case where we started with something line "/" or "/."
  42.  
  43.     if {("$newPath" == "") && [string match "/*" $pathName]} {
  44.         set newPath "/"}
  45.         
  46.     return $newPath
  47. }
  48.  
  49. #------------------------------------------------------------------------------
  50. # Take the help current directory and a path and evaluate it into a help root-
  51. # based path name.
  52.  
  53. proc help:EvalPath {pathName} {
  54.     global TCLENV
  55.  
  56.     if {![string match "/*" $pathName]} {
  57.         if {"$pathName" == ""} {
  58.             return $TCLENV(help:curDir)}
  59.         if {"$TCLENV(help:curDir)" == "/"} {
  60.             set pathName "/$pathName"
  61.         } else {
  62.             set pathName "$TCLENV(help:curDir)/$pathName"
  63.         }
  64.     }
  65.     set pathName [help:flattenPath $pathName]
  66.     if {[string match "*/" $pathName] && ($pathName != "/")} {
  67.         set pathName [csubstr $pathName 0 [expr [length $pathName]-1]]}
  68.  
  69.     return $pathName    
  70. }
  71.  
  72. #------------------------------------------------------------------------------
  73. # Display a line of output, pausing waiting for input before displaying if the
  74. # screen size has been reached.  Return 1 if output is to continue, return
  75. # 0 if no more should be outputed, indicated by input other than return.
  76. #
  77.  
  78. proc help:Display {line} {
  79.     global TCLENV
  80.     if {$TCLENV(help:lineCnt) >= 23} {
  81.         set TCLENV(help:lineCnt) 0
  82.         puts stdout ":" nonewline
  83.         flush stdout
  84.         gets stdin response
  85.         if {![lempty $response]} {
  86.             return 0}
  87.     }
  88.     puts stdout $line
  89.     incr TCLENV(help:lineCnt)
  90. }
  91.  
  92. #------------------------------------------------------------------------------
  93. # Display a file.
  94.  
  95. proc help:DisplayFile {filepath} {
  96.  
  97.     set inFH [open $filepath r]
  98.     while {[gets $inFH fileBuf] >= 0} {
  99.         if {![help:Display $fileBuf]} {
  100.             break}
  101.     }
  102.     close $inFH
  103.  
  104. }    
  105.  
  106. #------------------------------------------------------------------------------
  107. # Procedure to return contents of a directory.  A list is returned, consisting
  108. # of two lists.  The first list are all the directories (subjects) in the
  109. # specified directory.  The second is all of the help files.  Eash sub-list
  110. # is sorted in alphabetical order.
  111. #
  112.  
  113. proc help:ListDir {dirPath} {
  114.     set dirList {}
  115.     set fileList {}
  116.     if {[catch {set dirFiles [glob $dirPath/*]}] != 0} {
  117.         error "No files in subject directory: $dirPath"}
  118.     foreach fileName $dirFiles {
  119.         if [file isdirectory $fileName] {
  120.             lappend dirList "[file tail $fileName]/"
  121.         } else {
  122.             lappend fileList [file tail $fileName]
  123.         }
  124.     }
  125.    return [list [lsort $dirList] [lsort $fileList]]
  126. }
  127.  
  128. #------------------------------------------------------------------------------
  129. # Display a list of file names in a column format. This use columns of 14 
  130. # characters 3 blanks.
  131.  
  132. proc help:DisplayColumns {nameList} {
  133.     set count 0
  134.     set outLine ""
  135.     foreach name $nameList {
  136.         if {$count == 0} {
  137.             append outLine "   "}
  138.         append outLine $name
  139.         if {[incr count] < 4} {
  140.             set padLen [expr 17-[clength $name]]
  141.             if {$padLen < 3} {
  142.                set padLen 3}
  143.             append outLine [replicate " " $padLen]
  144.         } else {
  145.            if {![help:Display $outLine]} {
  146.                return}
  147.            set outLine ""
  148.            set count 0
  149.         }
  150.     }
  151.     if {$count != 0} {
  152.         help:Display $outLine}
  153.     return
  154. }
  155.  
  156.  
  157. #------------------------------------------------------------------------------
  158. # Help command main.
  159.  
  160. proc help {{subject {}}} {
  161.     global TCLENV
  162.  
  163.     set TCLENV(help:lineCnt) 0
  164.  
  165.     # Special case "help help", so we can get it at any level.
  166.  
  167.     if {($subject == "help") || ($subject == "?")} {
  168.         help:DisplayFile "$TCLENV(help:root)/help"
  169.         return
  170.     }
  171.  
  172.     set request [help:EvalPath $subject]
  173.     set requestPath "$TCLENV(help:root)$request"
  174.  
  175.     if {![file exists $requestPath]} {
  176.         error "Help:\"$request\" does not exist"}
  177.     
  178.     if [file isdirectory $requestPath] {
  179.         set dirList [help:ListDir $requestPath]
  180.         set subList  [lindex $dirList 0]
  181.         set fileList [lindex $dirList 1]
  182.         if {[llength $subList] != 0} {
  183.             help:Display "\nSubjects available in $request:"
  184.             help:DisplayColumns $subList
  185.         }
  186.         if {[llength $fileList] != 0} {
  187.             help:Display "\nHelp files available in $request:"
  188.             help:DisplayColumns $fileList
  189.         }
  190.     } else {
  191.         help:DisplayFile $requestPath
  192.     }
  193.     return
  194. }
  195.  
  196.  
  197. #------------------------------------------------------------------------------
  198. # Helpcd main.
  199. #   
  200. # The name of the new current directory is assembled from the current 
  201. # directory and the argument.  The name will be flatten and any trailing
  202. # "/" will be removed, unless the name is just "/".
  203.  
  204. proc helpcd {{dir /}} {
  205.     global TCLENV
  206.  
  207.     set request [help:EvalPath $dir]
  208.     set requestPath "$TCLENV(help:root)$request"
  209.  
  210.     if {![file exists $requestPath]} {
  211.         error "Helpcd: \"$request\" does not exist"}
  212.     
  213.     if {![file isdirectory $requestPath]} {
  214.         error "Helpcd: \"$request\" is not a directory"}
  215.  
  216.     set TCLENV(help:curDir) $request
  217.     return    
  218. }
  219.  
  220. #------------------------------------------------------------------------------
  221. # Helpcd main.
  222.  
  223. proc helppwd {} {
  224.         global TCLENV
  225.         echo "Current help subject directory: $TCLENV(help:curDir)"
  226. }
  227.  
  228. #==============================================================================
  229. #     Tcl apropos command.  (see Tcl shell manual)
  230. #------------------------------------------------------------------------------
  231.  
  232. proc apropos {name} {
  233.     global TCLENV
  234.  
  235.     set TCLENV(help:lineCnt) 0
  236.  
  237.     set aproposCT [scancontext create]
  238.     scanmatch -nocase $aproposCT $name {
  239.         set path [lindex $matchInfo(line) 0]
  240.         set desc [lrange $matchInfo(line) 1 end]
  241.         if {![help:Display [format "%s - %s" $path $desc]]} {
  242.             return}
  243.     }
  244.     foreach brief [glob -nocomplain $TCLENV(help:root)/*.brf] {
  245.         set briefFH [open $brief]
  246.         scanfile $aproposCT $briefFH
  247.         close $briefFH
  248.     }
  249.     scancontext delete $aproposCT
  250. }
  251.  
  252. #------------------------------------------------------------------------------
  253. # One time initialization done when the file is sourced.
  254. #
  255. global TCLENV TCLPATH
  256.  
  257. set TCLENV(help:root) [searchpath $TCLPATH help]
  258. set TCLENV(help:curDir) "/"
  259. set TCLENV(help:outBuf) {}
  260.